; _____ _ __ __ _
; | __ \ (_) \ \ / / | |
; | |__) |__ _ _ __ ___ _ _ __ __ _ \ \ /\ / /___ _ __ __| |___
; | ___// _` | '__/ __| | '_ \ / _` | \ \/ \/ // _ \| '__/ _` / __|
; | | | (_| | | \__ \ | | | | (_| | \ /\ /| (_) | | | (_| \__ \
; |_| \__,_|_| |___/_|_| |_|\__, | \/ \/ \___/|_| \__,_|___/
; __/ |
; |___/
; Dictionary lookup and associated parsing words
; EXPECT addr +n -- M,83
; Receive characters and store each into memory. The transfer begins at addr
; proceeding towards higher addresses one byte per character until either a
; "return" is received or until +n characters have been transferred.
; No more than +n characters will be stored.
; The "return" is not stored into memory.
; No characters are received or transferred if +n is zero.
; All characters actually received and stored into memory will be displayed,
; with the "return" displaying as a space. See: SPAN "9.5.2 EXPECT"
expcth data copywh,6
text 'EXPECT'
expect data $+2
clr @in ; clear >IN variable
clr r14 ; counter for number of characters
; *actually* in the buffer
mov *stack+,r13 ; pop length in r13
mov *stack+,r10 ; pop address address in r10
mov r13,r13 ; check length
jeq zchars ; quit if 0 characters requested
expnxt bl @kscn ; scan keyboard (wait for a keypress)
; ascii code returned on the stack
; check for enter key...
c *stack,@datCR ; compare to carriage return (enter key)
jeq exp2 ; exit routine if enter was pressed
; ; check for backspace key...
c *stack,@lit8+4 ; compare to backspace key
jne skipbs ; skip if backspace not pressed
inct stack ; remove backspace from stack
mov r14,r14 ; check if anything in the buffer
jeq expnxt ; tib is empty, ignore...
; do backspace...
bl @ccp ; compute cursor position
li r1,>2000 ; load a space character
bl @vsbw ; erase the cursor
mov @scrX,r0 ; get current x position
jne back1 ; if x>0 we don't need to move up one line
mov @xmax,@scrX ; move to end of line
dec @scrX ; correct X
dec @scrY ; up one screen line
mov @scrY,r0 ; check y
jlt bumpY ; if <0 then reset to 0
jmp back2
back1 dec @scrX ; move back one character
back2 dec r14 ; decrement buffer index pointer
dec r10 ; decrement buffer position
jmp expnxt ; get another keypress
bumpY inc @scrY ; prevent Y from going <0
jmp back2
; process keypress...
skipbs dect stack ; new stack entry
mov @2(stack),*stack ; duplicate value on stack for EMIT
bl @emit_ ; call emit (which may/may not call SCRLUP)
swpb *stack ; shift ascii code into MSB
mov *stack+,r1
mov r10,r0
inc r10
bl @vsbw0
inc r14 ; increment 'number of characters in buffer so far'
; counter
c r14,@tibsiz ; do we have #TIB characters in the buffer?
jeq exp1 ; if so, exit the routine
c r13,r14 ; have we got 'length' characters?
jne expnxt ; read another key if not
exp1 mov r14,@_span ; move character count into _span
b @space1+2 ; type a space to the console and exit
exp2 inct stack ; pop ascii 13 off the stack
jmp exp1
; special case if 0 characters were requested for some weird reason...
zchars clr @_span
b *next
datCR data 13 ; ascii code for carriage return
; Comments: ( \ & .(
; Allows comments e.g. : 1TO3 ( comment) 1 2 3 ;
; Reads through the TIB until ) is found or end of line
remh data expcth,immed+1
text '( '
rem data docol
data lit,')',word,drop2
data exit
trcomh data remh,immed+1
text '\ '
trcom data $+2
bl @bank1
data _trcom
typcmh data trcomh,immed+2
text '.('
data docol,lit,41,word,type,cr,exit
; WORD ( delimiter -- address length )
; Moves through TIB in VDP memory, discarding leading delimiters, looking for
; a word. A word is identified when a trailing delimiter is detected.
; The word is copied from VDP to CPU memory.
; Pushes the start address of the word (in CPU memory), and the length of
; the word to the stack.
; If no word is found (for example if we hit the end of the TIB without
; detecting a word then 0 0 is pushed on the stack.
wordh data typcmh,4
text 'WORD'
word data docol
; tib @ blk @ ?dup if nip block then
data tib_,fetch
word0 data blk,fetch,qdup,zbrnch,word2,nip,fblock
word2 data word1
data exit
; at this point, data stack is ( delimeter address -- )
; where address is the address in vdp to start searching from.
; address is either TIB+>IN (if BLK=0) or block address+>IN
; if BLK>0. (the code to add >IN to the address is in _word)
word1 data $+2
bl @bank1
data _word ; see 1-08-Parsing.a99
; BL ( -- 32 )
; pushes 32 decimal to the stack. BL is short for 'BLANK' often used in with
; word to specify the delimeter: e.g. BL WORD
blh data wordh,2
text 'BL'
bl_ data docol,lit,32,exit
; FIND addr1 len -- addr2 n 83
; addr1 is the address of a string. The string contains a word name to be
; located in the currently active search order. If the word is not found, addr2
; is the string address addr1, and n is zero.
; If the word is found, addr2 is the compilation address and n is set to one of
; two non-zero values. If the word found has the immediate attribute,
; n is set to one. If the word is non-immediate, n is set to minus one (true).
; Len indicates the length of the string beginnig at addr1.
findh data blh,4
text 'FIND'
find data docol,lit,fndvec,fetch,execut,exit
vfind data $+2 ; vectored find
mov *stack+,r6 ; pop length to r6
mov @latest,r7 ; get address of last dictionary entry
fndnxt mov @2(r7),r8 ; length of dictionary entry
andi r8,>400f ; mask out immediate bit and block numbers
c r8,r6 ; are they the same length?
jeq lmatch ; jump if yes
find1 mov *r7,r7 ; point to next dictionary entry
jeq nomatch ; if 0 then no match. end of dictionary.
jmp fndnxt ; else check the next entry
; the length matches.
; now do a character comparison between the word in the buffer and the word
; in the dictionary
lmatch mov r7,r10
ai r10,4 ; point to text of dictionary entry
mov *stack,r0 ; buffer address in r0
cnxtch movb *r0+,r1 ; otherwise get a character from buffer
bl @caschk ; convert case if case sensitive=off
mov r1,r14 ; save the character
movb *r10+,r1 ; get character from dictionary entry
bl @caschk ; convert case if case sensitive=off
find2 cb r1,r14 ; compare the two characters
jne find1 ; if not equal then check next dict entry
dec r8 ; decrememnt length
jne cnxtch ; if not 0 then check next character
; we have a match push cfa and word type
mov @2(r7),r8 ; get length of dictionary entry
mov r8,r9 ; make a copy
andi r8,>f ; retain length only
a r8,r7 ; add length
ai r7,4 ; take account of address & link field
inc r7 ; round up...
andi r7,>fffe ; ...to even address
mov r7,*stack ; push cfa
dect stack ; prepare to push 'n' (see stack sig)
l8000 andi r9,immed ; check immediate bit
jeq noimm ; if not set then push -1 for status
li r1,1 ; else push a 1
mov r1,*stack
b *next
noimm seto *stack ; not immediate - push -1
b *next
nomatch dect stack ; leave address unchanged on stack
clr *stack ; 0=not found
b *next
; Convert lower case characters to upper case if case sensitivity is turned off
; Input: r1 msb = character to test
; Output: r1 msb = upper case character
caschk movb @cassen,r13 ; case sensitive mode switched off?
jne casout ; skip case conversion if switched off
movb r1,r13 ; get the character in a spare register
srl r13,8 ; move to low byte
ci r13,'a' ; compare to a
jlt casout ; if less than it's not a lower case char
ci r13,'z' ; else compare to z
jgt casout ; if greater than it's not a lower case char
li r13,-32*256 ; it's lower case. load -32 in the upper byte
ab r13,r1 ; subtract -32 from the upper byte.
; char is now upper case
casout rt
; NUMBER ( address length -- number flag )
; Attempts to convert the string at address into a number. If fully successful,
; the number is placed on the stack and flag will be 0. If it fails (for example
; contains an illegal character) then a partial number will be placed on the
; stack (the value computed up until the failure) and flag will be >0.
; Thus, if flag>0 the string failed to parse fully as a number.
; A minus sign is permitted for negative numbers.
; This routine uses BASE to parse numbers in the current BASE.
; Eg. If BASE=16 then digits 0-9 and A-F are considered legal and will be
; parsed properly.
; A facility also exists called 'quick hex' that allows a number to be entered
; in base 16, by placing a $ symbol at the end of the string. This avoids the
; need to change BASE to enter a number. E.g. instead of HEX FEED DECIMAL you
; can simply do $FEED. The number will be parsed as a HEX number without the
; need to change BASE.
; The numbers returned are (by default) singles (16 bits). NUMBER can can also
; return a double (32-bit (2 stack cells)) value by including a period in the
; number string. E.g. 100. 1.00 10.0 .100 will all return 100 decimal as a
; double.
; The various facilities can be mixed. For example, f. means -15 as a double.
; - $ and . can be specified in any order. However, $ if required, should be
; specified before any number digits. - and . can come anywhere in the string.
; in the number string.
numbrh data findh,6
text 'NUMBER'
number data docol,lit,numvec,fetch,execut,exit ; fetch NUMBER vector & execute
numbr1 data $+2
bl @bank1
data _numbr ; see 1-08-Parsing.a99
; EVALUATE ( i*x c-addr u -- j*x)
; evaluates the string specified by c-addr u
; the interpretation state is stored before evaluation and restored afterwards
; should not be directly called within a block (or when BLK>0)
evalh data numbrh,8
text 'EVALUATE'
eval data docol
data in_,fetch,rspush
data blk,fetch,rspush
data span,fetch,rspush
data tib_,fetch,rspush
data in_,store0 ; zero >IN
data blk,store0 ; zero BLK
data span,store ; load #tib with u
data tib_,store ; load tib with c-addr
data litm1,lit,source,store ; set SOURCE-ID to -1
data interp ; call interpreter
data lit,source,store0